home *** CD-ROM | disk | FTP | other *** search
/ FM Towns: Free Software Collection 4 / FM Towns Free Software Collection 4 - Disc 1.iso / t_os / bcm332 / bcm332.bas next >
BASIC Source File  |  1991-10-18  |  11KB  |  295 lines
  1. 10000 CLS
  2. 10100 LOCATE 10,0:PRINT "　Ｂｌａｃｋ　Ｔｏｏｌ　Ｓｅｒｉｅｓ　ｖｏｌ．１"
  3. 10200 LOCATE 20,1:PRINT "Ｂ.キャラメイカーＶｅｒ３.３Ｌ１１"
  4. 10300 LOCATE 10,2:PRINT "　Ｃｏｐｙｒｉｇｈｔ　（ｃ）　“Ｈ　ＫＵＲＯＤＡ“　１９９１"
  5. 10400 LOCATE 10,3:PRINT "　Ｄｅｖｅｌｏｐｅｄ　ｂｙ　　“Ｈ　ＫＵＲＯＤＡ“"
  6. 10500 LOCATE 10,5:PRINT "    Ｈｉｔ　ａｎｙ　ｋｅｙ":WHILE INKEY$="":WEND
  7. 10600 '初期設定
  8. 10700 CLS:SCREEN@ 1:CLEAR ,,,600000:DEFINT A-Z:VIEW:WINDOW
  9. 10800 DIM CHA(16*3*16*3),UND(16*3*16*3),GE(0),SC(320*240),RAM(16*3*3*16*3*3):R=31:B=31:G=31
  10. 10900 LINE (0,0)-(193,193),PSET,7,B
  11. 11000 LINE (200,0)-(48+201,48+1),PSET,7,B:PUT@A (201,1)-(248,48),CHA:PUT@A (1,1)-(48,48),CHA,PSET,4,4
  12. 11100 '
  13. 11200 RESTORE 11200:FOR I=1 TO 4:READ ME$(I):NEXT I:DATA "自由線","直線","塗る","多角形":GOSUB *FREE_SET
  14. 11300 LINE (0,200)-(65,225),PSET,3,B
  15. 11400 GOTO 13100
  16. 11500 *G_SET
  17. 11600 LINE (1,201)-(64,208),PSET,4,BF,4:LINE (67,201)-(84,208),PSET,0,BF,0:LINE (G*2+1,201)-(G*2+2,208),PSET,0,BF,0
  18. 11700 SYMBOL (67,201),MID$(STR$(G),2),1,.5!,7
  19. 11800 RETURN
  20. 11900 *R_SET
  21. 12000 LINE (1,209)-(64,216),PSET,2,BF,2:LINE (67,209)-(84,216),PSET,0,BF,0:LINE (R*2+1,209)-(R*2+2,216),PSET,0,BF,0
  22. 12100 SYMBOL (67,209),MID$(STR$(R),2),1,.5!,7
  23. 12200 RETURN
  24. 12300 *B_SET
  25. 12400 LINE (1,217)-(64,224),PSET,1,BF,1:LINE (67,217)-(84,224),PSET,0,BF,0
  26. 12500 SYMBOL (67,217),MID$(STR$(B),2),1,.5!,7:LINE (B*2+1,217)-(B*2+2,224),PSET,0,BF,0
  27. 12600 RETURN
  28. 12700 *COLOR_SET
  29. 12800 LINE (100,200)-(125,225),PSET,7,BF,[(G+1)*8-1,(R+1)*8-1,(B+1)*8-1]
  30. 12900 PAL=G*2^10+R*2^5+B
  31. 13000 RETURN
  32. 13100 GOSUB *G_SET:GOSUB *R_SET:GOSUB *B_SET:GOSUB *COLOR_SET
  33. 13200 'マウス設定
  34. 13300 MOUSE 0
  35. 13400 MOUSE 1,200,200,1:ON MOUSE(2) GOSUB *MAIN:ON MOUSE(4) GOSUB *GET_COLOR:MOUSE(2) ON:MOUSE(4) ON
  36. 13500 'その他設定
  37. 13600 CONSOLE 0,0,1
  38. 13700 KEY 1,"直線":KEY 2,"塗る":KEY 3,"自由線":KEY 4,"戻す":KEY 5,"消す":KEY 6,"保存他":KEY 7,"終了":GOSUB *KEY_SET:GOTO 14800
  39. 13800 *KEY_SET
  40. 13900 ON KEY(1) GOSUB *LINE_SET
  41. 14000 ON KEY(2) GOSUB *PAINT_SET
  42. 14100 ON KEY(3) GOSUB *FREE_SET
  43. 14200 ON KEY(4) GOSUB *UNDO
  44. 14300 ON KEY(5) GOSUB *CLS
  45. 14400 ON KEY(6) GOSUB *RAM_MAIN
  46. 14500 ON KEY(7) GOSUB *END
  47. 14600 FOR I=1 TO 7:KEY(I) ON:NEXT I
  48. 14700 RETURN
  49. 14800 '
  50. 14900 GOTO 14900
  51. 15000 *MAIN 
  52. 15100 GOSUB *MOUSE_ICHI
  53. 15200 IF MX>0 AND MX<193 AND MY>0 AND MY<193 THEN *BIG
  54. 15300 IF MX>200 AND MX<249 AND MY>0 AND MY<49 THEN *SMALL
  55. 15400 IF MX>0 AND MX<65 AND MY>0 AND MY<225 THEN *COLOR
  56. 15500 RETURN
  57. 15600 *SMALL 
  58. 15700 GOSUB *KEY_OFF
  59. 15800 MX1=MX:MY1=MY
  60. 15900 GOSUB *U_GET:ON PAT GOTO 16000,16600,17200
  61. 16000 WHILE MOUSE(2,0)=-1:GOSUB *MOUSE_ICHI:IF MX>200 AND MX<249 AND MY>0 AND MY<49 THEN AX=1:GOTO 16100 ELSE 16500
  62. 16100 MX2=MX:MY2=MY
  63. 16200 LINE (MX1,MY1)-(MX2,MY2),PSET,[(G+1)*8-1,(R+1)*8-1,(B+1)*8-1]:GOSUB *SMALL_GET
  64. 16300 MX1=MX2:MY1=MY2
  65. 16400 WEND
  66. 16500 GOSUB *SMALL_GET:GOSUB *KEY_SET:RETURN
  67. 16600 GOSUB *MOUSE_OFF:GOSUB *U_GET:PSET (MX1,MY1),[(G+1)*8-1,(R+1)*8-1,(B+1)*8-1]:WHILE MOUSE(2,0)=-1:WEND
  68. 16700 IF MOUSE(2,0)=-1 THEN GOSUB *MOUSE_ICHI:GOTO 16800 ELSE 16700
  69. 16800 IF MX>200 AND MX<249 AND MY>0 AND MY<49 THEN 16900 ELSE 16700
  70. 16900 LINE (MX1,MY1)-(MX,MY),PSET,[(G+1)*8-1,(R+1)*8-1,(B+1)*8-1]
  71. 17000 GOSUB *SMALL_GET:IF MX1=MX AND MY1=MY THEN 17100 ELSE WHILE MOUSE(2,0)=-1:WEND:MX1=MX:MY1=MY:GOTO 16700
  72. 17100 GOSUB *MOUSE_ON:GOSUB *KEY_SET:GOSUB *FREE_SET:RETURN
  73. 17200 GOSUB *U_GET
  74. 17300 PAINT@ (MX1,MY1),[(G+1)*8-1,(R+1)*8-1,(B+1)*8-1]:LINE (200,0)-(249,49),PSET,7,B
  75. 17400 GOSUB *SMALL_GET:GOSUB *KEY_SET:GOSUB *MOUSE_ON:RETURN
  76. 17500 GOTO 17100
  77. 17600 *BIG
  78. 17700 GOSUB *KEY_OFF:GOSUB *MOUSE_ICHI:MX1=INT((MX-1)/4):MY1=INT((MY-1)/4)
  79. 17800 GOSUB *U_GET:ON PAT GOTO *B_FREE,*B_LINE,*B_PAINT
  80. 17900 *B_FREE
  81. 18000 MX2=MX1:MY2=MY1:WHILE MOUSE(2,0)=-1
  82. 18100 LINE (201+MX1,1+MY1)-(201+MX2,1+MY2),PSET,[(G+1)*8-1,(R+1)*8-1,(B+1)*8-1]
  83. 18200 GOSUB *MOUSE_ICHI:MX1=MX2:MY1=MY2:GOSUB *MOUSE_ICHI
  84. 18300 IF MX>0 AND MX<193 AND MY>0 AND MY<193 THEN 18400 ELSE 18200
  85. 18400 MX2=INT((MX-1)/4):MY2=INT((MY-1)/4):GOSUB *SMALL_GET:WEND
  86. 18500 GOSUB *SMALL_GET:GOSUB *KEY_SET
  87. 18600 RETURN
  88. 18700 *B_LINE
  89. 18800 PSET (201+MX1,1+MY1),[(G+1)*8-1,(R+1)*8-1,(B+1)*8-1]
  90. 18900 GOSUB *SMALL_GET
  91. 19000 IF MOUSE(2,0)=-1 THEN 19000
  92. 19100 IF MOUSE(2,0)=0 THEN 19100
  93. 19200 GOSUB *MOUSE_ICHI
  94. 19300 MX2=INT((MX-1)/4):MY2=INT((MY-1)/4):IF MX2>=0 AND MX2<48 AND MY2>=0 AND MY2<48 THEN 19400 ELSE 19200
  95. 19400 LINE (201+MX1,1+MY1)-(201+MX2,1+MY2),PSET,[(G+1)*8-1,(R+1)*8-1,(B+1)*8-1]
  96. 19500 GOSUB *SMALL_GET:GOSUB *KEY_SET
  97. 19600 IF MX1=MX2 AND MY1=MY2 THEN GOSUB *FREE_SET:RETURN ELSE MX1=MX2:MY1=MY2:GOTO 18900
  98. 19700 *B_PAINT
  99. 19800 MX1=INT((MX-1)/4):MY1=INT((MY-1)/4)
  100. 19900 MX1=201+MX1:MY1=1+MY1:GOTO 17200
  101. 20000 *RAM_MAIN
  102. 20100 CONSOLE 0,0,1:REC=0:GC=1:GOSUB *KEY_OFF:GOSUB *MOUSE_OFF
  103. 20200 CLS:PUT@A (0,0)-(143,143),RAM,PSET,1,1
  104. 20300 LINE (250,0)-(299,49),PSET,7,B
  105. 20400 PUT@A (251,1)-(298,48),CHA,PSET,1,1:GOTO 20900
  106. 20500 LINE (250,50)-(265,65),PSET,7,B:LINE (251,51)-(264,64),XOR,7,BF,7
  107. 20600 SYMBOL (250,50),"←",1,1,1
  108. 20700 LINE (250,70)-(265,85),PSET,7,B:LINE (251,71)-(264,84),XOR,7,BF,7
  109. 20800 SYMBOL (250,70),"→",1,1,1:RETURN
  110. 20900 LINE (251,71)-(264,84),PSET,7,BF,7
  111. 21000 GOSUB 20500
  112. 21100 FOR I=1 TO 6:KEY I,"":NEXT I
  113. 21200 KEY 1,"SAVE":KEY 2,"LOAD":KEY 3,"MAIN"
  114. 21300 FOR I=1 TO 3:KEY(I) ON:NEXT
  115. 21400 ON KEY(1) GOSUB *SAVE
  116. 21500 ON KEY(2) GOSUB *LOAD
  117. 21600 ON KEY(3) GOSUB *GO_MAIN
  118. 21700 MOUSE(2) ON
  119. 21800 ON MOUSE(2) GOSUB 22000
  120. 21900 IF REC=1 THEN RETURN 10900:ELSE 21900
  121. 22000 GOSUB *MOUSE_ICHI
  122. 22100 IF MX>=0 AND MX<=143 AND MY>=0 AND MY<=143 THEN 22500
  123. 22200 IF MX>=250 AND MX<=265 AND MY>=50 AND MY<=65 AND GC=2 THEN GC=1:GOSUB 20500:RETURN
  124. 22300 IF MX>=250 AND MX<=265 AND MY>=70 AND MY<=85 AND GC=1 THEN GC=2:GOSUB 20500:RETURN
  125. 22400 RETURN
  126. 22500 MX=INT(MX/48):MY=INT(MY/48)
  127. 22600 MX=MX*48:MY=MY*48
  128. 22700 IF GC=1 THEN 22800 ELSE 23100
  129. 22800 PUT@A (MX,MY)-(MX+47,MY+47),CHA,PSET,1,1
  130. 22900 GET@A (0,0)-(143,143),RAM
  131. 23000 RETURN
  132. 23100 GET@A (MX,MY)-(MX+47,MY+47),CHA
  133. 23200 PUT@A (251,1)-(298,48),CHA,PSET,1,1
  134. 23300 RETURN
  135. 23400 *SAVE
  136. 23500 GOSUB *MOUSE_OFF:GOSUB *KEY_OFF:GET@A (0,0)-(143,143),RAM
  137. 23600 CLS
  138. 23700 CONSOLE 0,0,0
  139. 23800 PRINT "１：シーケンシャル形式"
  140. 23900 PRINT "２：Ｆ－ＢＡＳＩＣ形式"
  141. 24000 PRINT "３：臨時保存"
  142. 24100 PRINT "０：中止"
  143. 24200 WAIT 10
  144. 24300 K$=INKEY$
  145. 24400 IF K$="1" THEN *S_SAVE
  146. 24500 IF K$="2" THEN *F_SAVE
  147. 24600 IF K$="0" THEN RETURN 20000
  148. 24700 IF K$="3" THEN *L_SAVE
  149. 24800 GOTO 24300
  150. 24900 *S_SAVE
  151. 25000 KAK$=".DAT":FC=0:GOSUB *FILES
  152. 25100 IF OK=0 THEN RETURN 20000
  153. 25200 CLS:PUT@A (0,0)-(143,143),RAM
  154. 25300 DIM SA(16*3*16*3):OPEN "O",#1,NA$:FOR Y=0 TO 2
  155. 25400   FOR X=0 TO 2
  156. 25500   GET@A (X*16*3,Y*16*3)-(X*16*3+16*3-1,Y*16*3+16*3-1),SA
  157. 25600   FOR I=0 TO 2303 STEP 8
  158. 25700   PRINT#1,"&H"+HEX$(SA(I))+",&H"+HEX$(SA(I+1))+",&H"+HEX$(SA(I+2))+",&H"+HEX$(SA(I+3))+",&H"+HEX$(SA(I+4))+",&H"+HEX$(SA(I+5))+",&H"+HEX$(SA(I+6))+",&H"+HEX$(SA(I+7))
  159. 25800   NEXT I:LINE (X*16*3,Y*16*3)-(X*16*3+16*3-1,Y*16*3+16*3-1),PSET,7,BF,1
  160. 25900   NEXT X
  161. 26000   NEXT Y
  162. 26100   ERASE SA:CLOSE #1
  163. 26200   RETURN 20000
  164. 26300 *F_SAVE
  165. 26400 KAK$=".BAS":FC=0:GOSUB *FILES
  166. 26500 IF OK=0 THEN RETURN 20000
  167. 26600 CLS:PUT@A (0,0)-(143,143),RAM
  168. 26700 DIM SA(16*3*16*3):LIS&=29990:OPEN "O",#1,NA$:CC=-1:GOSUB *LIST:PRINT#1,LIS$+"Ｂ．キャラクター・メイカー　Ｖ３．３Ｌ１０ｍ"
  169. 26800   FOR Y=0 TO 2:FOR X=0 TO 2:CC=CC+1:GOSUB *LIST:GET@A (X*16*3,Y*16*3)-(X*16*3+16*3-1,Y*16*3+16*3-1),SA
  170. 26900   PRINT#1,LIS$+"'B.ｷｬﾗ3.3("+MID$(STR$(CC),2)+")"
  171. 27000   FOR I=0 TO 2303 STEP 8
  172. 27100   GOSUB *LIST
  173. 27200   GOSUB *PRINT:PRINT#1,P$
  174. 27300 NEXT I:LINE (X*16*3,Y*16*3)-(X*16*3+16*3-1,Y*16*3+16*3-1),PSET,7,BF,1
  175. 27400 NEXT X:NEXT Y
  176. 27500 ERASE SA:CLOSE #1
  177. 27600 RETURN 20000
  178. 27700 *LOAD
  179. 27800 GOSUB *MOUSE_OFF:GOSUB *KEY_OFF:GET@A (0,0)-(143,143),RAM
  180. 27900 CLS:FC=1:KAK$=".DAT":GOSUB *FILES
  181. 28000 CLS:DIM SA(144*144-1):LOAD@ NA$,SA
  182. 28100 PUT@A (0,0)-(143,143),SA:BEEP
  183. 28200 ERASE SA:GET@A (0,0)-(143,143),RAM
  184. 28300 RETURN 20000
  185. 28400 *UNDO
  186. 28500 PUT@A (201,1)-(248,48),UND,PSET,1,1:PUT@A (1,1)-(48,48),UND,PSET,4,4
  187. 28600 GET@A (201,1)-(248,48),CHA
  188. 28700 RETURN
  189. 28800 *LINE_SET PAT=2:GOTO *SYM_MENU
  190. 28900 *PAINT_SET PAT=3:GOTO *SYM_MENU
  191. 29000 *FREE_SET PAT=1:GOTO *SYM_MENU
  192. 29100 *MOUSE_ICHI
  193. 29200 MX=MOUSE(0):MY=MOUSE(1)
  194. 29300 RETURN
  195. 29400 *CLS
  196. 29500 GET@A (201,1)-(248,48),UND
  197. 29600 LINE (201,1)-(248,48),PSET,0,BF,0
  198. 29700 GET@A (201,1)-(248,48),CHA:PUT@A (1,1)-(48,48),CHA,PSET,4,4
  199. 29800 RETURN
  200. 29900 *KEY_OFF
  201. 30000 FOR I=1 TO 8
  202. 30100 KEY(I) OFF
  203. 30200 NEXT I
  204. 30300 RETURN
  205. 30400 *MOUSE_OFF
  206. 30500 MOUSE(2) OFF
  207. 30600 MOUSE(4) OFF
  208. 30700 RETURN
  209. 30800 *MOUSE_ON
  210. 30900 MOUSE(2) ON
  211. 31000 MOUSE(4) ON
  212. 31100 RETURN
  213. 31200 *COLOR
  214. 31300 GOSUB *MOUSE_OFF
  215. 31400 C=MX-1:C=INT(C/2)
  216. 31500 IF MY>=201 AND MY<=208 THEN G=C
  217. 31600 IF MY>=209 AND MY<=216 THEN R=C
  218. 31700 IF MY>=217 AND MY<=224 THEN B=C
  219. 31800 FOR I=1 TO 4
  220. 31900 ON I GOSUB *G_SET,*R_SET,*B_SET,*COLOR_SET
  221. 32000 NEXT I
  222. 32100 GOSUB *MOUSE_ON
  223. 32200 RETURN
  224. 32300 *RET
  225. 32400 RETURN
  226. 32500 *U_GET
  227. 32600 GET@A (201,1)-(248,48),UND
  228. 32700 RETURN
  229. 32800 *SMALL_GET
  230. 32900 GET@A (201,1)-(248,48),CHA
  231. 33000 PUT@A (1,1)-(48,48),CHA,PSET,4,4
  232. 33100 RETURN
  233. 33200 *GET_COLOR
  234. 33300 GOSUB *MOUSE_ICHI
  235. 33400 GET@A (MX,MY)-(MX,MY),GE
  236. 33500 GE=GE(0) AND &H7FFF
  237. 33600 B=GE AND 31:GE=GE\32:R=GE AND 31:GE=GE\32:G=GE AND 31
  238. 33700 FOR I=1 TO 3:ON I GOSUB *R_SET,*G_SET,*B_SET:NEXT I
  239. 33800 GOSUB *COLOR_SET
  240. 33900 RETURN
  241. 34000 *SYM_MENU
  242. 34100 LINE (135,200)-(200,239),PSET,0,BF,0
  243. 34200 SYMBOL (135,200),ME$(PAT),1,1,7
  244. 34300 RETURN
  245. 34400 *GO_MAIN
  246. 34500 CLS
  247. 34600 REC=1:RETURN
  248. 34700 *FILES
  249. 34800 CLS
  250. 34900 PRINT "半角でファイル名を入力して下さい（拡張子はいりません）"
  251. 35000 INPUT "",NA$:IF NA$="" THEN RETURN 20000
  252. 35100 NA$=LEFT$(NA$,8):NA$="A:"+NA$+KAK$
  253. 35200 ON ERROR GOTO *FER_1:OPEN "I",#1,NA$:CLOSE #1
  254. 35300 ON ERROR GOTO 0:COLOR 7,0:IF FC=0 THEN KILL NA$
  255. 35400 OK=1:RETURN
  256. 35500 *FER_1
  257. 35600 COLOR 7,0:RESUME 35700
  258. 35700 COLOR 7,0:
  259. 35800 OK=1:IF FC=0 THEN RETURN
  260. 35900 CLS
  261. 36000 PRINT "ファイルがありません HIT ANY KEY"
  262. 36100 WHILE INKEY$="":WEND:RETURN 20000
  263. 36200 *LIST
  264. 36300 LIS&=LIS&+10:LIS$=MID$(STR$(LIS&),2)+" ":
  265. 36400 RETURN
  266. 36500 *PRINT
  267. 36600 DIM SA$(7):FOR N=0 TO 7
  268. 36700 FOR N=0 TO 7
  269. 36800 SA$=HEX$(SA(I+N)):L=LEN(SA$):ON L GOTO 36900,37000,37100,37200
  270. 36900 SA$="&H000"+SA$:GOTO 37300
  271. 37000 SA$="&H00"+SA$:GOTO 37300
  272. 37100 SA$="&H0"+SA$:GOTO 37300
  273. 37200 SA$="&H"+SA$:GOTO 37300
  274. 37300 SA$(N)=SA$
  275. 37400 NEXT N
  276. 37500 P$=LIS$+"DATA "
  277. 37600 FOR N=0 TO 6
  278. 37700 P$=P$+SA$(N)+","
  279. 37800 NEXT N
  280. 37900 P$=P$+SA$(7)
  281. 38000 ERASE SA$:RETURN
  282. 38100 *END
  283. 38200 DIM ENDDATA(320*240):GET@A (0,0)-(319,239),ENDDATA
  284. 38210 CLS:PRINT "終了していいですか？"
  285. 38220 YN$=INKEY$:IF YN$="Y" OR YN$="y" THEN CLS:END ELSE IF YN$="N" OR YN$="n" THEN 38230 ELSE 38220
  286. 38230 PUT@A (0,0)-(319,239),ENDDATA
  287. 38240 ERASE ENDDATA:RETURN
  288. 38400 *L_SAVE
  289. 38500 DIM L_SAVE(144*144-1):PUT@A (0,0)-(143,143),RAM
  290. 38600 GET@A (0,0)-(143,143),L_SAVE
  291. 38700 KAK$=".DAT":FC=0:GOSUB *FILES
  292. 38800 SAVE@ NA$,L_SAVE
  293. 38900 ERASE L_SAVE
  294. 39000 RETURN 20000
  295.